Shareware Grab Bag/Shareware Grab Bag.iso/007/simcode.arc/UPDOWN.PAS

Pascal/Delphi Source File | 1985-01-19 | 22KB | 868 lines

{$symtab-,$pagesize:85,$linesize:96,$debug-,
$title:'UPDOWN.PAS -- Send files back and forth'}
{    COPYRIGHT @ 1982
    Jim Holtman and Eric Holtman
    35 Dogwood Trail
    Randolph, NJ 07869
    [phone]
}
{$include:'stdio.inc'}
{$list-}
{$include:'filkqq.inc'}
{$list+,Included 'filkqq.inc'}

 module updown;

     uses
     filkqq,stdio;
{$include:'simterm.inc'}
{$include:'graph.inc'}
{$include:'comm.inc'}

     const
         Ctrl_X = chr(#18);

     var
     display_buffer_addr [external] : word;
     total_errors : integer;

     procedure ck(a : integer;
         const b : string);

     external;

     function getc(flag : LOOP_FLAG) : integer;

     external;

     procedure putchar(inchar : char);

     external;

     procedure savescreen;

     external;

     procedure restorescreen;

     external;

     function com_get(var inch : char) : boolean;

     external;

     function x_cont(new : boolean) : boolean;

     external;

     procedure net_pack(source,dest : adrmem;
         size : word);

     external;

     procedure net_unpack(source,dest : adrmem;
         size : word);

     external;

     procedure clear_to_bot;

     var
         i,x,y : integer;

     begin               {clear display}
         xrcurp(x,y);
         xwca(NULLB,(RIGHT_MAR+1)-x);
         for i := y+1 to BOTTOM do begin
         xxmove(LEFT_MAR,i);
         xwca(NULLB,(RIGHT_MAR+1))   end;
         xxmove(x,y);
         end;

     procedure cursor_on;
     begin
        if display_buffer_addr = #B800 then
           xscurt(byword(6,7))    {color graphics}
        else
           xscurt(byword(11,12));    {monochrome}
        end;

     procedure cursor_off;
     begin
        cursor_on;    {make sure it is ON corectly}
        xscurt(byword(14,14));  {then turn it OFF}
        end;

     procedure disp_data(b,e : integer);

     begin
         if e>0 then total_errors := total_errors+1;
         xxmove(0,2);
         writeln('Last Acknowledged Block: ',b);
         writeln('Errors: ', e,'/',total_errors);
         clear_to_bot;
         end;

     procedure print_counter(count : word);

     var
         outstr : lstring(20);

     begin
         if count = 0 then begin
         xxmove(0,10);
         xttywrt('Any key will terminate transfer',7);
         xxmove(0,12);
         xttywrt('# of bytes transferred -',7);
         end
         else begin
         xxmove(24,12);
         eval(encode(outstr,count));
         xttywrt(outstr,#70);
                   {reverse video}
         end;
         end;

     procedure parse_file(var infile : lstring) [public];

     var
         dir : lstring(100);
         index,str_len : integer;

     begin
         str_len := ord(infile.len);
         index := scaneq(-str_len,'\',infile,str_len);
         if index+str_len <> 0 then begin
         copylst(infile,dir);
         delete(dir,index+str_len,1-index);
         delete(infile,1,index+str_len);
         if c_chdir(dir) < 0 then writeln(output,'Directory ',dir,
             ' not found.');
         end;
         end;

     procedure down_load_remote(const fn : lstring) [public];

     const
         LF = 10;           {line feed}
         BELL_EOF = 7;       {A 'bell' signifies the end-of-file}
         TEXT_EOF = 26;       {Text end of file character}
         PRINT_LIMIT = #f;       {output byte count every 16th character}

     var
         ibmfile : file of char;
         infile, outfile : lstring(100);
         cmd_str : lstring(255);
         inchar : integer;
         char_count : word;
         inkey : char;
         bypass_flag : boolean;

     begin
         bypass_flag := false;
         savescreen;
         xxcls;
         xxmove(0,0);
         writeln(output,'TEXT file DOWNLOAD (UNIX -> PC)');
         write(output,'From UNIX file: ');
         if (fn.len = 0) then readln(input,infile)
         else begin
         copylst(fn, infile);
         writeln(infile);
         end;
         write(output,'To IBM file (RETURN only to use same name): ');
         if (fn.len = 0) then readln(input,outfile)
         else begin
         copylst(fn, outfile);
         writeln(outfile);
         end;
         parse_file(outfile);  {if no output file specified, use the input
                      file name}
         if outfile.len = 0 then outfile := infile;
         assign(ibmfile,outfile);
         ibmfile.trap := true;
         rewrite(ibmfile);
         if ibmfile.errs <> 0 then begin
         writeln(output,chr(7)*'File not found.'*chr(7));
         sleep(2);
         return;
         end;
         if (fn.len = 0) then begin
         cmd_str := null;
         concat(cmd_str,'cat ');
         concat(cmd_str,infile);
         concat(cmd_str,'; echo '*chr(7)*chr(10));
         send(cmd_str);
         repeat
             inchar := getc(HANG);
             until inchar = LF;
         end;
         char_count := 0;
         cursor_off;
         print_counter(0);       {print the header line}
         repeat
{$mathck-}
         inchar := getc(HANG);
         if inchar = BELL_EOF then ibmfile^ := chr(TEXT_EOF)
         else ibmfile^ := chr(inchar);
         put(ibmfile);
         char_count := char_count + 1;
         if (char_count and #f) = 0 then print_counter(char_count);
         if xxinkey(inkey) <> 0 then begin
                   {terminate transmission}
             eval(breaker);{send interrupt}
             bypass_flag := true;
             end;
{$mathck+}
         until (inchar = BELL_EOF) or (bypass_flag);
         repeat           {eat the final line feed}
         inchar := getc(HANG)
         until (inchar = LF) or bypass_flag;
         cursor_on;
         close(ibmfile);
         restorescreen;
         writeln(output,chr(7)*chr(10)*chr(13)*
             '  **download complete. bytes transferred=',char_count);
         end;

     procedure down_load;

     var
         l : lstring(2);

     begin
         l.len := 0;
         down_load_remote(l);
         end;

     procedure up_load_remote(const fn : lstring) [public];

     const
         LF = chr(10);
         TEXT_EOF = chr(26);

     var
         ibmfile : file of char;
         infile, outfile : lstring(100);
         cmd_str : lstring(255);
         no_of_LFs : integer;
         inchar : char;
         char_count : word;
         wait_flag : boolean;
         i : integer;
         inkey : char;
         bypass_flag : boolean;

     begin
         bypass_flag := false;
         savescreen;
         xxcls;
         xxmove(0,0);
         writeln(output,'TEXT file UPLOAD (PC -> UNIX)');
         write(output,'From IBM file: ');
         if (fn.len = 0) then begin
         readln(input,infile);
         end
         else begin
         copylst(fn, infile);
         writeln(infile);
         end;
         parse_file(infile);
         write(output,'To UNIX file (RETURN only to use same name): ');
         if (fn.len = 0) then begin
         readln(input,outfile);
                   {If the output file is not specified, use the
                      input file as default}
         if outfile.len = 0 then begin
             outfile := infile;
             i := positn(':',outfile,1);
                   {delete unit specification if present}
             if i > 0 then delete(outfile,1,i);
             end;
         end
         else begin
         copylst(fn, outfile);
         writeln(outfile);
         end;
         assign(ibmfile,infile);
         ibmfile.trap := true; {allow catching of errors}
         reset(ibmfile);
         if ibmfile.errs <> 0 then begin
         writeln(chr(7)*'****** File Not Found on Disk:',infile);
         sleep(2);
         restorescreen;
         return;
         end;
         cmd_str := null;
{The 'echo' after 'stty -echo' generates a LF so that the program
     will look for 2 LFs before starting the Upload; this prevents
     the first couple of characters from being echoed}
         concat(cmd_str,'stty -echo;echo x;cat >');
         concat(cmd_str,outfile);
         concat(cmd_str,';stty echo'*chr(10));
                   {put on RETURN}
         char_count := 0;
         cursor_off;
         print_counter(0);       {print header}
         if (fn.len = 0) then begin
         send(cmd_str);
         for no_of_LFs := 1 to 2 do
                   {make sure 'stty -echo' is set}
             repeat       {'eat' command echo}
             inchar := chr(getc(HANG))
             until inchar = LF   ;
         end;           {Now copy the file over to UNIX}
         while not eof(ibmfile) do begin
         inchar := ibmfile^;
         case inchar of
             LF: ;       {ignore}

             TEXT_EOF:       {encountered text eof, exit}
                 break;

             otherwise
             begin
{$mathck-}
                 send(inchar);
                 char_count := char_count+1;
                 if (char_count and #f) = 0 then print_counter(
                     char_count);
{$mathck+}
                 end;
             end;
         if xxinkey(inkey) <> 0 then begin
             send(chr(13));    {output line terminator}
             break;
             end;
         get(ibmfile);
         end;
         if (fn.len = 0) then begin
         send(chr(4));    {send ^D}
         end
         else begin
         send(chr(26)*chr(13)); {send ^Z}
         end;
         cursor_on;
         close(ibmfile);
         restorescreen;
         if (fn.len = 0 ) then writeln(output,chr(7)*chr(10)*chr(13)*
             '  **upload complete. bytes transferred =',char_count);
         end;

     procedure up_load;

     var
         l : lstring(2);

     begin
         l.len := 0;
         up_load_remote(l);
         end;

     procedure dump_file;

     label
         10;

     const
         TEXT_EOF = chr(26);

     var
         ibmfile : file of char;
         infile : lstring(100);
         inchar : char;
         wait_flag : boolean;
         wait_str : lstring(10);
         clock_tick : ads of word;
         wait_ticks,start_time : word;

     begin
         clock_tick.s := 0;    {address timer in low core}
         clock_tick.r := #46C;
         savescreen;
         xxcls;
         xxmove(0,0);
         write(output,'From IBM file: ');
         readln(input,infile);
         parse_file(infile);
         wait_flag := FALSE;
         assign(ibmfile,infile);
         ibmfile.trap := TRUE; {allow trapping fo errors}
         reset(ibmfile);
         if ibmfile.errs <> 0 then begin
         writeln(chr(7)*'***** File Not Found on Disk *****:',infile);
         sleep(2);
         restorescreen;
         return;
         end;
         write(output,'Clock tick delays between characters (0=>none): ');
         readln(input,wait_ticks);
         if wait_ticks > 0 then wait_flag := TRUE;
 10:
{$mathck-}
         while not eof(ibmfile) do begin
         inchar := ibmfile^;
         if inchar = TEXT_EOF then break;
         send(inchar);
         putchar(inchar);  {echo to screen}
         if xxinkey(inchar) <> 0 then break;
         if wait_flag then begin
             start_time := clock_tick^;
             while (clock_tick^-start_time) < wait_ticks do;
             end;
         get(ibmfile);
         end;
{$mathck+}
         writeln(output,chr(7)*'*** Dump Complete ***');
         close(ibmfile);
         restorescreen;
         end;

     function get_x_char(wait_time : word) : integer;

     var
         inchar : char;
         start,diff : word;

     begin
         start := timer;
         repeat
{$mathck-}
         if not com_get(inchar) then begin
             get_x_char := ord(inchar);
                   {
                 ***DEBUG***write(output,'.',ord(inchar):2:16);}
             return;
             end;
         diff := timer - start;
         until diff > wait_time;
         get_x_char := -1;       {error return}
{$mathck+}
         end;

     procedure purge_send(send_char:byte);

     var
         send_string : string(1);

     begin
         repeat
         until get_x_char(1) < 0;
         send_string[1] := chr(send_char);
         send(send_string);
         end;

     procedure xmodem_down_remote(const fn : lstring) [public];

     label
         20,30;

     const
         X_SOH = wrd(#1);
         X_SOH40 = wrd(#41);
         X_EOT = wrd(#4);
         X_ACK = wrd(#6);
         X_NAK = wrd(#15);
         X_CAN = wrd(#18);

     var
         recv_buf : array[1..176] of byte;
         pack_buf : array[1..132] of byte;
         str_ptr : adr of string(128);
         char_cnt : integer;
         err_cnt : integer;
         blk_cnt,msg_len : integer;
         check_sum : word;
         inchar : integer;
         i : integer;
         outfile : lstring(100);
         ibmfile : file of string(128);
         inkey : char;
         old_xon : boolean;

     begin
         total_errors := 0;
         savescreen;
         xxcls;
         xxmove(0,0);
         write(output,'File for XMODEM Receive: ');
         if (fn.len = 0) then readln(input,outfile)
         else begin
         copylst(fn, outfile);
         writeln(outfile);
         end;
         parse_file(outfile);
         assign(ibmfile,outfile);
         ibmfile.trap := true;
         rewrite(ibmfile);
         if ibmfile.errs<>0 then begin
         writeln(output,chr(7)*'File not found'*chr(7));
         sleep(2);
         restorescreen;
         return;
         end;
         old_xon := x_cont(false);
                   {turn off the xon/xoff}
         err_cnt := 0;
         blk_cnt := 1;
         str_ptr := adr recv_buf[4];
         purge_send(X_NAK);
         writeln(output,'Hit "Esc" key OR "^X" to terminate RECEIVE');
         sleep(1);
         cursor_off;
         xxcls;
         xxmove(0,0);
         writeln('File: ',outfile);
 30:
         while TRUE do begin
         if xxinkey(inkey) <> 0 then

             if ((inkey = chr(27)) or (inkey = chr(24))) then begin
                   {User typed ESCAPE}
             purge_send(X_CAN);
             writeln(output,'User cancelled receive');
             sleep(2);
             cursor_on;
             restorescreen;
             eval(x_cont(old_xon));
             return;
             end   ;
         char_cnt := 0;
         inchar := get_x_char(10);
         if inchar < 0 then begin
             writeln(output,'Timeout on block #',blk_cnt);
             goto 20;  {count up the errors}
             end;
         if not(wrd(inchar) in [X_SOH,X_SOH40,X_EOT,X_CAN]) then begin
             writeln(output,'Header not correct. ',inchar:2:16);
             goto 20;  {count up the errors}
             end;
         if wrd(inchar) = X_SOH40 then msg_len := 176
         else msg_len := 132;
         char_cnt := char_cnt+1;
         recv_buf[char_cnt] := wrd(inchar);
         repeat
             inchar := get_x_char(1);
             if inchar<0 then begin
             if char_cnt = 1 then break;
                   {EOT are sometimes sent as single characters}
             writeln(output,'Short block #',blk_cnt,char_cnt);
 20:
             err_cnt := err_cnt+1;
             if err_cnt>12 then begin
                 writeln(output,'Receive cancelled due to errors');
                 purge_send(X_CAN);
                 sleep(2);
                 restorescreen;
                 cursor_on;
                 eval(x_cont(old_xon));
                 return;
                 end;
             purge_send(X_NAK);
             cycle 30;
             end;
             char_cnt := char_cnt+1;
             recv_buf[char_cnt] := wrd(inchar);
             until char_cnt >= msg_len;
         if recv_buf[1] = X_CAN then begin
             writeln(output,'Transmitter cancelled');
             sleep(2);
             restorescreen;
             cursor_on;
             eval(x_cont(old_xon));
             return;
             end;
         if recv_buf[1] = X_EOT then begin
             writeln(output,chr(7)*'Received verified'*chr(7));
             close(ibmfile);
             send(chr(X_ACK));
             sleep(2);
             restorescreen;
             cursor_on;
             eval(x_cont(old_xon));
             return;
             end;
         if msg_len = 176 then begin
                   {data from NET/1 -- pack it}
             net_pack(adr recv_buf[1],adr pack_buf[1],132);
             for i := 1 to 132 do recv_buf[i] := pack_buf[i];
             end;
         if (recv_buf[2] xor recv_buf[3])<>#FF then begin
             writeln(output,'Header error block #',blk_cnt, recv_buf[2]:
                 2:16, recv_buf[3]:2:16);
             goto 20;
             end;
         if recv_buf[2] = wrd((blk_cnt-1) and #FF) then begin
             send(chr(X_ACK));
             writeln(output,'Duplicate blocks #',blk_cnt);
             cycle;
             end;
         if recv_buf[2] <> wrd(blk_cnt and #FF) then begin
             writeln(output,'Block count not correct. Expecting',blk_cnt
                 and #FF, ' and got',ord(recv_buf[2]));
             goto 20;
             end;
         check_sum := 0;
         for i := 1 to 128 do check_sum := check_sum + recv_buf[i+3];
         if (check_sum and #FF) <> recv_buf[132] then begin
             writeln(output,'Checksum error block #',blk_cnt,check_sum
                 and #FF, recv_buf[132]);
             goto 20;
             end;
         send(chr(X_ACK));
         ibmfile^ := str_ptr^;
         put(ibmfile);
         disp_data(blk_cnt, err_cnt);
         blk_cnt := blk_cnt+1;
         err_cnt := 0;
         end;
         end;

     procedure xmodem_down [public];

     var
         l : lstring(2);

     begin
         l.len := 0;
         xmodem_down_remote(l);
         end;

     procedure xmodem_up_remote(const fn : lstring) [public];

     const
         soh = #01;
         eot = #04;
         ack = #06;
         nak = #15;
         can = #18;

     var
         i,j : integer;
         ch : string(1);
         blocknum : word;
         numread : integer;
         cksum : integer;
         net_line : boolean;
         inch : char;
         fp : file of string(128);
         name : lstring(60);
         blockbuf : lstring(132);
         unpack_buf : lstring(176);
         last_block : boolean;
         length,nread : integer;
         errors : integer;
         old_xon : boolean;

     procedure do_send(c : word);

         var
         s : string(1);

         begin
         s[1] := chr(c);
         send(s);
         end;

     procedure clear_iq;

         var
         j : integer;

         begin
         repeat
             j := get_x_char(2);
             until j = -1;
         end;

     procedure read_in;

         var
         ii : integer;
         c : byte;

         begin
         copylst(fp^,blockbuf);
         insert('...',blockbuf,1);
         get(fp);
         if eof(fp) then last_block := true;
         end;

     begin
         savescreen;
         last_block := false;
         total_errors := 0;
         errors := 0;
         xxcls;
         xxmove(0,0);
         old_xon := x_cont(false);
                   {turn off XON/XOFF}
         write('File name for XMODEM transmit: ');
         if (fn.len = 0) then readln(name)
         else begin
         copylst(fn, name);
         writeln(name);
         end;
         if name[1] = '&' then begin
         net_line := true;
         delete(name,1,1);
         end
         else net_line := false;
         parse_file(name);
         assign(fp, name);
         fp.trap := TRUE;       {catch non-existent file}
         fp.mode := DIRECT;
         reset(fp);
         if fp.errs<>0 then begin
         purge_send(wrd(can));
                   {terminate XMODEM}
         writeln('Non-existent file - ',name);
         sleep(2);
         restorescreen;
         eval(x_cont(old_xon));
         return;
         end;
         length := ord(fp.dosf.z2 * 512 + fp.dosf.z1 div 128);
         if (fp.dosf.z1 and #7F) <> 0 then length := length + 1;
         nread := length;
         writeln('File length is ',length:4,' blocks');
         writeln('Ready for transmission.......');
         writeln('Type ^X to exit..............');
         blocknum := 1;
         i := get_x_char(60);
         if ((i = -1) or (i <> nak) or (xxinkey(inch) >0)) then begin
         writeln('Did not get a startup NAK, got a', i);
         purge_send(wrd(can));
         eval(x_cont(old_xon));
         return;
         end;
         xxcls;
         cursor_off;
         xxmove(0,0);
         writeln('File name: ',name);
         writeln('Total blocks: ',length);
         read_in;
         while (true) do begin
         if (xxinkey(inch) = 1) then
           if inch = Ctrl_X then begin
             writeln('User cancelled transmit');
             purge_send(wrd(can));
             sleep(2);
             restorescreen;
             cursor_on;
             eval(x_cont(old_xon));
             return;
             end;
         if (errors > 10) then begin
             writeln('Transmit cancelled due to errors');
             purge_send(wrd(can));
             sleep(2);
             restorescreen;
             cursor_on;
             eval(x_cont(old_xon));
             return;
             end;
         blockbuf[1] := chr(soh);
         blockbuf[2] := chr(blocknum and #FF);
         blockbuf[3] := chr((not blocknum) and #FF);
         cksum := 0;
         for i := 1 to 128 do begin
             cksum := cksum + ord(blockbuf[i+3]);
             end;
         blockbuf[132] := chr(cksum and #FF);
         blockbuf[0] := chr(132);
         if net_line then begin
             net_unpack(adr blockbuf[1],adr unpack_buf[1],176);
             unpack_buf[0] := chr(176);
             send(unpack_buf);
             end
         else send(blockbuf);
         j := get_x_char(15);
         if (j = nak) then begin
             writeln('got a nak on block', blocknum);
                   { clear_iq; }
             errors := errors + 1;
             cycle;
             end;
         if (j = can) then begin
             writeln('got a can on block', blocknum);
             sleep(2);
             restorescreen;
             cursor_on;
             eval(x_cont(old_xon));
             return;
             end;
         if ((j >= 0) and (j <> ack)) then begin
             writeln('got a strange response(',j,') on block', blocknum)
                 ;
             clear_iq;
             errors := errors + 1;
             cycle;
             end;
         if (j = -1) then begin
             writeln('Timeout on block', blocknum);
             errors := errors + 1;
             cycle;
             end;
         disp_data(ord(blocknum), errors);
         if           {(last_block = true) or}
             (blocknum = wrd(length)) then break;
         read_in;
         blocknum := blocknum + 1;
         errors := 0;
         end;
         while (true) do begin
         if (xxinkey(inch) = 1) then
           if inch = Ctrl_X then begin
             writeln('User cancelled receive');
             purge_send(wrd(can));
             sleep(2);
             restorescreen;
             cursor_on;
             eval(x_cont(old_xon));
             return;
             end;
         do_send(eot);
         j := get_x_char(10);
         if (j = nak) then begin
             writeln('got a nak on EOT');
                   {  clear_iq;  }
             errors := errors + 1;
             cycle;
             end;
         if (j = can) then begin
             writeln('got a can on EOT');
             sleep(2);
             restorescreen;
             cursor_on;
             eval(x_cont(old_xon));
             return;
             end;
         if ((j >= 0) and (j <> ack)) then begin
             writeln('got a strange response on EOT');
             clear_iq;
             cycle;
             end;
         if (j = -1) then begin
             writeln('Timeout on EOT');
             cycle;
             end;
         writeln(chr(7)*'Acknowledged EOT'*chr(7));
         break;
         end;
         sleep(2);
         restorescreen;
         cursor_on;
         eval(x_cont(old_xon));
         end;

     procedure xmodem_up [public];

     var
         l : lstring(2);

     begin
         l.len := 0;
         xmodem_up_remote(l);
         end;   end.